home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
kcl.lha
/
c
/
sequence.d
< prev
next >
Wrap
Lisp/Scheme
|
1987-06-03
|
9KB
|
491 lines
/*
(c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
Copying of this file is authorized to users who have executed the true and
proper "License Agreement for Kyoto Common LISP" with SIGLISP.
*/
/*
sequence.d
sequence routines
*/
#include "include.h"
#undef endp
#define endp(obje) ((enum type)((endp_temp = (obje))->d.t) == t_cons ? \
FALSE : endp_temp == Cnil ? TRUE : \
(bool)FEwrong_type_argument(Slist, endp_temp))
object endp_temp;
/*
I know the following name is not good.
*/
object
alloc_simple_vector(l, aet)
int l;
enum aelttype aet;
{
object x;
x = alloc_object(t_vector);
x->v.v_hasfillp = FALSE;
x->v.v_adjustable = FALSE;
x->v.v_displaced = Cnil;
x->v.v_dim = x->v.v_fillp = l;
x->v.v_self = NULL;
x->v.v_elttype = (short)aet;
return(x);
}
object
alloc_simple_bitvector(l)
int l;
{
object x;
x = alloc_object(t_bitvector);
x->bv.bv_hasfillp = FALSE;
x->bv.bv_adjustable = FALSE;
x->bv.bv_displaced = Cnil;
x->bv.bv_dim = x->bv.bv_fillp = l;
x->bv.bv_offset = 0;
x->bv.bv_self = NULL;
return(x);
}
Lelt()
{
check_arg(2);
vs_base[0] = elt(vs_base[0], fixint(vs_base[1]));
vs_pop;
}
object
elt(seq, index)
object seq;
int index;
{
int i;
object l;
if (index < 0) {
vs_push(make_fixnum(index));
FEerror("Negative index: ~D.", 1, vs_head);
}
switch (type_of(seq)) {
case t_cons:
for (i = index, l = seq; i > 0; --i)
if (endp(l))
goto E;
else
l = l->c.c_cdr;
if (endp(l))
goto E;
return(l->c.c_car);
case t_vector:
case t_bitvector:
if (index >= seq->v.v_fillp)
goto E;
return(aref(seq, index));
case t_string:
if (index >= seq->st.st_fillp)
goto E;
return(code_char(seq->ust.ust_self[index]));
default:
FEerror("~S is not a sequence.", 1, seq);
}
E:
vs_push(make_fixnum(index));
FEerror("The index, ~D, is too large", 1, vs_head);
}
siLelt_set()
{
check_arg(3);
vs_base[0] = elt_set(vs_base[0], fixint(vs_base[1]), vs_base[2]);
vs_pop;
vs_pop;
}
object
elt_set(seq, index, val)
object seq;
int index;
object val;
{
int i;
object l;
if (index < 0) {
vs_push(make_fixnum(index));
FEerror("Negative index: ~D.", 1, vs_head);
}
switch (type_of(seq)) {
case t_cons:
for (i = index, l = seq; i > 0; --i)
if (endp(l))
goto E;
else
l = l->c.c_cdr;
if (endp(l))
goto E;
return(l->c.c_car = val);
case t_vector:
case t_bitvector:
if (index >= seq->v.v_fillp)
goto E;
return(aset(seq, index, val));
case t_string:
if (index >= seq->st.st_fillp)
goto E;
if (type_of(val) != t_character)
FEerror("~S is not a character.", 1, val);
seq->st.st_self[index] = val->ch.ch_code;
return(val);
default:
FEerror("~S is not a sequence.", 1, seq);
}
E:
vs_push(make_fixnum(index));
FEerror("The index, ~D, is too large", 1, vs_head);
}
@(defun subseq (sequence start &optional end &aux x)
int s, e;
int i, j;
@
s = fixnnint(start);
if (end == Cnil)
e = -1;
else
e = fixnnint(end);
switch (type_of(sequence)) {
case t_symbol:
if (sequence == Cnil) {
if (s > 0)
goto ILLEGAL_START_END;
if (e > 0)
goto ILLEGAL_START_END;
@(return Cnil)
}
FEwrong_type_argument(Ssequence, sequence);
case t_cons:
if (e >= 0)
if ((e -= s) < 0)
goto ILLEGAL_START_END;
while (s-- > 0) {
if (type_of(sequence) != t_cons)
goto ILLEGAL_START_END;
sequence = sequence->c.c_cdr;
}
if (e < 0)
@(return `copy_list(sequence)`)
for (i = 0; i < e; i++) {
if (type_of(sequence) != t_cons)
goto ILLEGAL_START_END;
vs_check_push(sequence->c.c_car);
sequence = sequence->c.c_cdr;
}
vs_push(Cnil);
while (e-- > 0)
stack_cons();
x = vs_pop;
@(return x)
case t_vector:
if (s > sequence->v.v_fillp)
goto ILLEGAL_START_END;
if (e < 0)
e = sequence->v.v_fillp;
else if (e < s || e > sequence->v.v_fillp)
goto ILLEGAL_START_END;
x = alloc_simple_vector(e - s, sequence->v.v_elttype);
array_allocself(x, FALSE);
switch (sequence->v.v_elttype) {
case aet_object:
case aet_fix:
case aet_sf:
for (i = s, j = 0; i < e; i++, j++)
x->v.v_self[j] = sequence->v.v_self[i];
break;
case aet_lf:
for (i = s, j = 0; i < e; i++, j++)
x->lfa.lfa_self[j] =
sequence->lfa.lfa_self[i];
break;
}
@(return x)
case t_string:
if (s > sequence->st.st_fillp)
goto ILLEGAL_START_END;
if (e < 0)
e = sequence->st.st_fillp;
else if (e < s || e > sequence->st.st_fillp)
goto ILLEGAL_START_END;
x = alloc_simple_string(e - s);
x->st.st_self = alloc_relblock(e - s);
for (i = s, j = 0; i < e; i++, j++)
x->st.st_self[j] = sequence->st.st_self[i];
@(return x)
case t_bitvector:
if (s > sequence->bv.bv_fillp)
goto ILLEGAL_START_END;
if (e < 0)
e = sequence->bv.bv_fillp;
else if (e < s || e > sequence->bv.bv_fillp)
goto ILLEGAL_START_END;
x = alloc_simple_bitvector(e - s);
x->bv.bv_self = alloc_relblock((e-s+7)/8);
s += sequence->bv.bv_offset;
e += sequence->bv.bv_offset;
for (i = s, j = 0; i < e; i++, j++)
if (sequence->bv.bv_self[i/8]&(0200>>i%8))
x->bv.bv_self[j/8]
|= 0200>>j%8;
else
x->bv.bv_self[j/8]
&= ~(0200>>j%8);
@(return x)
default:
FEwrong_type_argument(Ssequence, vs_base[0]);
}
ILLEGAL_START_END:
FEerror("~S and ~S are illegal as :START and :END~%\
for the sequence ~S.", 3, start, end, sequence);
@)
Lcopy_seq()
{
check_arg(1);
vs_push(small_fixnum(0));
Lsubseq();
}
int
length(x)
object x;
{
int i;
switch (type_of(x)) {
case t_symbol:
if (x == Cnil)
return(0);
FEwrong_type_argument(Ssequence, x);
case t_cons:
for (i = 0; !endp(x); i++, x = x->c.c_cdr)
;
return(i);
case t_vector:
case t_string:
case t_bitvector:
return(x->v.v_fillp);
default:
FEwrong_type_argument(Ssequence, x);
}
}
Llength()
{
check_arg(1);
vs_base[0] = make_fixnum(length(vs_base[0]));
}
Lreverse()
{
check_arg(1);
vs_base[0] = reverse(vs_base[0]);
}
object
reverse(seq)
object seq;
{
object x, y, *v;
int i, j, k;
switch (type_of(seq)) {
case t_symbol:
if (seq == Cnil)
return(Cnil);
FEwrong_type_argument(Ssequence, seq);
case t_cons:
v = vs_top;
vs_push(Cnil);
for (x = seq; !endp(x); x = x->c.c_cdr)
*v = make_cons(x->c.c_car, *v);
return(vs_pop);
case t_vector:
x = seq;
k = x->v.v_fillp;
y = alloc_simple_vector(k, x->v.v_elttype);
vs_push(y);
array_allocself(y, FALSE);
switch (x->v.v_elttype) {
case aet_object:
case aet_fix:
case aet_sf:
for (j = k - 1, i = 0; j >=0; --j, i++)
y->v.v_self[j] = x->v.v_self[i];
break;
case aet_lf:
for (j = k - 1, i = 0; j >=0; --j, i++)
y->lfa.lfa_self[j] = x->lfa.lfa_self[i];
break;
}
return(vs_pop);
case t_string:
x = seq;
y = alloc_simple_string(x->st.st_fillp);
vs_push(y);
y->st.st_self
= alloc_relblock(x->st.st_fillp);
for (j = x->st.st_fillp - 1, i = 0; j >=0; --j, i++)
y->st.st_self[j] = x->st.st_self[i];
return(vs_pop);
case t_bitvector:
x = seq;
y = alloc_simple_bitvector(x->bv.bv_fillp);
vs_push(y);
y->bv.bv_self
= alloc_relblock((x->bv.bv_fillp+7)/8);
for (j = x->bv.bv_fillp - 1, i = x->bv.bv_offset;
j >=0;
--j, i++)
if (x->bv.bv_self[i/8]&(0200>>i%8))
y->bv.bv_self[j/8] |= 0200>>j%8;
else
y->bv.bv_self[j/8] &= ~(0200>>j%8);
return(vs_pop);
default:
FEwrong_type_argument(Ssequence, seq);
}
}
Lnreverse()
{
check_arg(1);
vs_base[0] = nreverse(vs_base[0]);
}
object
nreverse(seq)
object seq;
{
object x, y, z;
int i, j, k;
switch (type_of(seq)) {
case t_symbol:
if (seq == Cnil)
return(Cnil);
FEwrong_type_argument(Ssequence, seq);
case t_cons:
for (x = Cnil, y = seq; !endp(y->c.c_cdr);) {
z = y;
y = y->c.c_cdr;
z->c.c_cdr = x;
x = z;
}
y->c.c_cdr = x;
return(y);
case t_vector:
x = seq;
k = x->v.v_fillp;
switch (x->v.v_elttype) {
case aet_object:
case aet_fix:
case aet_sf:
for (i = 0, j = k - 1; i < j; i++, --j) {
y = x->v.v_self[i];
x->v.v_self[i] = x->v.v_self[j];
x->v.v_self[j] = y;
}
return(seq);
case aet_lf:
for (i = 0, j = k - 1; i < j; i++, --j) {
longfloat y;
y = x->lfa.lfa_self[i];
x->lfa.lfa_self[i] = x->lfa.lfa_self[j];
x->lfa.lfa_self[j] = y;
}
return(seq);
}
case t_string:
x = seq;
for (i = 0, j = x->st.st_fillp - 1; i < j; i++, --j) {
k = x->st.st_self[i];
x->st.st_self[i] = x->st.st_self[j];
x->st.st_self[j] = k;
}
return(seq);
case t_bitvector:
x = seq;
for (i = x->bv.bv_offset,
j = x->bv.bv_fillp + x->bv.bv_offset - 1;
i < j;
i++, --j) {
k = x->bv.bv_self[i/8]&(0200>>i%8);
if (x->bv.bv_self[j/8]&(0200>>j%8))
x->bv.bv_self[i/8]
|= 0200>>i%8;
else
x->bv.bv_self[i/8]
&= ~(0200>>i%8);
if (k)
x->bv.bv_self[j/8]
|= 0200>>j%8;
else
x->bv.bv_self[j/8]
&= ~(0200>>j%8);
}
return(seq);
default:
FEwrong_type_argument(Ssequence, seq);
}
}
init_sequence_function()
{
make_function("ELT", Lelt);
make_si_function("ELT-SET", siLelt_set);
make_function("SUBSEQ", Lsubseq);
make_function("COPY-SEQ", Lcopy_seq);
make_function("LENGTH", Llength);
make_function("REVERSE", Lreverse);
make_function("NREVERSE", Lnreverse);
}